VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cQualityCenter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*******************************************************************************************
' Name : cQualityCenter.bas
' Author : Florent BREHERET
' Version : 1.10
' Last Update : 05/01/2012
' Description : Class to extract QualityCenter datas
' Methods :
'    Last_Server : return last server string used to connect a project
'    Last_Domain : return last domain string used to connect a project
'    Last_Project : return last project string used to connect a project
'    Last_User : return last user string used to connect a project
'    Last_Password : return last password string used to connect a project
'    InitConnection : Initialise the connection with the server
'    ReleaseConnection : Release the connection with the server
'    Login : Login a user
'    Logout : Logout a user
'    ConnectToProject : Connect to a domain/projet
'    DisconnectProject : Disconnect a domain/projet
'    Get_Domains : return a array of Domains
'    Get_Projects : return a array of Projects
'    Get_Full_Factory_Run : return datas from the Run factory
'    Get_Full_Factory_TestSet : return datas from the TestSet factory
'    Get_Full_Factory_Requirements : return datas from the Requirement factory
'    Get_Full_Factory_Bugs : return datas from the Bug factory
'    Get_Full_Factory_Tests : return datas from the Test factory
'    Get_Full_Factory_Tests_With_Steps : return datas from the Test ans Step factory
'    Get_Full_Factory_TestSet_With_Runs : return datas from the TestSet ans TSTest factory
'
' Example:
'    Dim lQc As New cQualityCenter
'    Dim lData As Variant
'    If lQc.InitConnection("http://server.com") Then
'        If lQc.Login("user", "password") Then
'            If lQc.ConnectToProject("domain", "project") Then
'                 lData = lQc.Get_Full_Factory_Bugs(SystemLabel, Null, Empty, False)
'                 lQc.DisconnectProject
'            End If
'            lQc.Logout
'        End If
'        lQc.ReleaseConnection
'    End If
'    Set lQc = Nothing
'    Cells.Resize(UBound(lData, 1), UBound(lData, 2)).Value = lData
'
'*******************************************************************************************

Option Explicit
Option Base 1

Private Const Setting_AppName = "QualityCenterExtractor"
Private Const Setting_Section = "Parameters"
Private Const Setting_Key = "qualitycenter"

Private G_QCConnection As Object 'TDAPIOLELib.TDConnection
Private G_AttachedProgressBar As Object
Private G_User As String
Private G_Password As String

Public Enum Label_T
    UserLabel = 1
    SystemLabel = 2
    SystemAndUserLabels = 3
End Enum

Private Enum Factory_T
    Requirements
    Tests
    TestSet
    TestSteps
    Bugs
    Runs
End Enum

Private Sub Class_Initialize()
    Dim lObjectsString() As Variant, i As Integer
    On Error Resume Next
    lObjectsString() = Array("TDApiOle80.TDConnection", "TDApiOle.TDConnection", "TDApiOle80.TDConnection.1")
    For i = LBound(lObjectsString) To UBound(lObjectsString)
        Err.Clear
        Set G_QCConnection = CreateObject(lObjectsString(i))
        If Err = 0 Then Exit For
    Next i
    If Err <> 0 Then MsgBox "Failed to create object from TDApiOle library!  ", vbCritical: End
End Sub

Private Sub Class_Terminate()
    Call ReleaseConnection
    Set G_QCConnection = Nothing
End Sub

Public Property Get Last_Server() As String
    Static lValue As String
    If lValue = Empty Then lValue = GetParam("Server")
    Last_Server = lValue
End Property

Public Property Get Last_Domain() As String
    Static lValue As String
    If lValue = Empty Then lValue = GetParam("Domain")
    Last_Domain = lValue
End Property

Public Property Get Last_Project() As String
    Static lValue As String
    If lValue = Empty Then lValue = GetParam("Project")
    Last_Project = lValue
End Property

Public Property Get Last_User() As String
    Static lValue As String
    If lValue = Empty Then lValue = GetParam("User")
    Last_User = lValue
End Property

Public Property Get Last_Password() As String
    Static lValue As String
    If lValue = Empty Then lValue = Decode(GetParam("Password"), Setting_Key)
    Last_Password = lValue
End Property

Public Property Set ProgressBar(ByRef pProgressBar As Object)
    Set G_AttachedProgressBar = pProgressBar
End Property

Public Property Get IsIntanciated() As Boolean
    IsIntanciated = Not (G_QCConnection Is Nothing)
End Property

Public Property Get IsConnected() As Boolean
    If IsIntanciated Then
        IsConnected = G_QCConnection.Connected
    End If
End Property

Public Property Get IsLoggedIn() As Boolean
    If IsConnected Then
        If OTAVersion > 8 Then
            IsLoggedIn = G_QCConnection.LoggedIn
        Else
            IsLoggedIn = (G_User <> Empty)
        End If
    End If
End Property

Public Property Get IsProjectConnected() As Boolean
    If IsLoggedIn Then
        If Not G_QCConnection Is Nothing Then IsProjectConnected = G_QCConnection.ProjectConnected
    End If
End Property

Public Property Get OTAVersion() As Integer
    Static lVersion As Integer
    If lVersion = 0 Then
        Dim majorVersion As String, minorVersion As String
        G_QCConnection.GetTDVersion majorVersion, minorVersion
        lVersion = CInt(majorVersion)
    End If
    OTAVersion = lVersion
End Property

Public Function InitConnection(pServer As String) As Boolean
    On Error Resume Next
    If Not IsIntanciated Then MsgBox "Libarary object is not instantiated!  " & vbCr & Err.Description, vbCritical: Exit Function
    If pServer = Empty Then MsgBox "Server address is empty !", vbCritical: Exit Function
    Call ReleaseConnection
    G_QCConnection.InitConnectionEx pServer
    If Err <> 0 Or G_QCConnection.Connected = False Then MsgBox "InitConnection() failed!  " & vbCr & Err.Description, vbCritical: Exit Function
    SetParam "Server", pServer
    InitConnection = True
End Function

Public Sub ReleaseConnection()
    On Error Resume Next
    If IsConnected Then
        Call Logout
        G_QCConnection.ReleaseConnection
    End If
    If Err Then MsgBox "TerminateConnection() failed!  " & vbCr & Err.Description, vbCritical
End Sub

Public Function Login(ByVal pUser As String, ByVal pPassword As String)
    On Error Resume Next
    If pUser = Empty Then MsgBox "User name is empty  !       ", vbCritical: Exit Function
    If Not IsConnected Then MsgBox "Connection has not been initialised !       ", vbCritical: Exit Function
    If OTAVersion > 8 Then
        Call Logout
        G_QCConnection.Login pUser, pPassword
        If Err <> 0 Or G_QCConnection.LoggedIn = False Then MsgBox "Login() failed!" & vbCr & Err.Description, vbCritical: Exit Function
    End If
    G_User = pUser
    G_Password = pPassword
    Login = True
End Function

Public Sub Logout()
    On Error Resume Next
    G_User = Empty
    G_Password = Empty
    If IsLoggedIn Then
        Call DisconnectProject
        If OTAVersion > 8 Then G_QCConnection.Logout
    End If
    If Err Then MsgBox "Logout() failed!" & vbCr & Err.Description, vbCritical
End Sub

Public Function ConnectToProject(ByVal pDomain As String, ByVal pProject As String)
    On Error Resume Next
    If Not G_QCConnection.Connected Then MsgBox "Connection has not been initialised !    ", vbCritical: Exit Function
    If Not IsLoggedIn Then MsgBox "You must Login first to connect a project !    " & vbCr & Err.Description, vbCritical: Exit Function
    Call DisconnectProject
    If OTAVersion > 8 Then
        G_QCConnection.Connect pDomain, pProject
    Else
        G_QCConnection.ConnectProjectEx pDomain, pProject, G_User, G_Password
    End If
    If Err <> 0 Or G_QCConnection.ProjectConnected = False Then MsgBox "ConnectToProject() failed!" & vbCr & Err.Description, vbCritical: Exit Function
    SetParam "User", G_User
    SetParam "Password", Encode(G_Password, Setting_Key)
    SetParam "Domain", pDomain
    SetParam "Project", pProject
    ConnectToProject = True
End Function

Public Sub DisconnectProject()
    On Error Resume Next
    If IsProjectConnected Then
        If OTAVersion > 8 Then
            G_QCConnection.Disconnect
        Else
            G_QCConnection.DisconnectProject
        End If
        If Err <> 0 Or G_QCConnection.ProjectConnected = True Then MsgBox "DisconnectProject() failed!" & vbCr & Err.Description, vbCritical
    End If
End Sub

Public Function Get_Domains() As Variant
    Get_Domains = Array()
    If Not IsLoggedIn Then MsgBox "You must Login first to get the Domain list !  " & vbCr & Err.Description, vbCritical
    If OTAVersion > 8 Then
        Get_Domains = Convert_StringCollection_ToArray(G_QCConnection.VisibleDomains)
    Else
        Get_Domains = Convert_StringCollection_ToArray(G_QCConnection.DomainsList)
    End If
End Function

Public Function Get_Projects(ByVal pDomain As Variant) As Variant
    Get_Projects = Array()
    If Not IsLoggedIn Then MsgBox "You must Login first to get the Project list !  " & vbCr & Err.Description, vbCritical
    If OTAVersion > 8 Then
        If pDomain = Empty Then MsgBox "Domain name is not optional to get the Project list  !  " & vbCr & Err.Description, vbCritical
        Get_Projects = Convert_StringCollection_ToArray(G_QCConnection.VisibleProjects(pDomain))
    Else
        If pDomain = Empty Then
            Get_Projects = Convert_StringCollection_ToArray(G_QCConnection.ProjectsList)
        Else
            Get_Projects = Convert_StringCollection_ToArray(G_QCConnection.ProjectsListEx(pDomain))
        End If
    End If
End Function

Public Function Get_Full_Factory_Run(pLabelType As Label_T, pFields As Variant, Optional pDataFilter As String, Optional pAttachement As Boolean) As Variant
    Dim lFieldList As Collection, lDataList As Object 'TDAPIOLELib.List
    Set lDataList = G_QCConnection.RunFactory.NewList(pDataFilter)
    Set lFieldList = Get_Active_Fields_Collection(lDataList.Fields, pFields)
    Get_Full_Factory_Run = Get_Factory_Data(Factory_T.Runs, pLabelType, lDataList, lFieldList, pAttachement)
End Function

Public Function Get_Full_Factory_TestSet(pLabelType As Label_T, pFields As Variant, Optional pDataFilter As String, Optional pAttachement As Boolean) As Variant
    Dim lFieldList As Collection, lDataList As Object 'TDAPIOLELib.List
    Set lDataList = G_QCConnection.TestSetFactory.NewList(pDataFilter)
    Set lFieldList = Get_Active_Fields_Collection(lDataList.Fields, pFields)
    Get_Full_Factory_TestSet = Get_Factory_Data(Factory_T.TestSet, pLabelType, lDataList, lFieldList, pAttachement)
End Function

Public Function Get_Full_Factory_Requirements(pLabelType As Label_T, pFields As Variant, Optional pDataFilter As String, Optional pAttachement As Boolean) As Variant
    Dim lFieldList As Collection, lDataList As Object 'TDAPIOLELib.List
    Set lDataList = G_QCConnection.ReqFactory.NewList(pDataFilter)
    Set lFieldList = Get_Active_Fields_Collection(lDataList.Fields, pFields)
    Get_Full_Factory_Requirements = Get_Factory_Data(Factory_T.Requirements, pLabelType, lDataList, lFieldList, pAttachement)
End Function

Public Function Get_Full_Factory_Bugs(pLabelType As Label_T, pFields As Variant, Optional pDataFilter As String, Optional pAttachement As Boolean) As Variant
    Dim lFieldList As Collection, lDataList As Object 'TDAPIOLELib.List
    Set lDataList = G_QCConnection.BugFactory.NewList(pDataFilter)
    Set lFieldList = Get_Active_Fields_Collection(lDataList.Fields, pFields)
    Get_Full_Factory_Bugs = Get_Factory_Data(Factory_T.Bugs, pLabelType, lDataList, lFieldList, pAttachement)
End Function

Public Function Get_Full_Factory_Tests(pLabelType As Label_T, pFields As Variant, Optional pDataFilter As String, Optional pAttachement As Boolean) As Variant
    Dim lFieldList As Collection, lDataList As Object 'TDAPIOLELib.List
    Set lDataList = G_QCConnection.testFactory.NewList(pDataFilter)
    Set lFieldList = Get_Active_Fields_Collection(lDataList.Fields, pFields)
    Get_Full_Factory_Tests = Get_Factory_Data(Factory_T.Tests, pLabelType, lDataList, lFieldList, pAttachement)
End Function

Public Function Get_Full_Factory_TestSet_With_Runs(pLabelType As Label_T, pFields As Variant, Optional pDataFilter As String, Optional pAttachement As Boolean) As Variant
    Dim lTestFieldList As Collection, lTestFieldCount As Integer, lTestDataCount As Integer, lTestDataList As Object ' TDAPIOLELib.List
    Dim lRunFieldList As Collection, lRunFieldCount As Integer, lRunFactory() As Object, lRunDataList As Object  'TDAPIOLELib.List
    Dim row As Long, row2 As Long, col As Integer, totalRuns As Long, rowpos As Long

    Set lTestDataList = G_QCConnection.TestSetFactory.NewList(pDataFilter)
    Set lTestFieldList = Get_Active_Fields_Collection(lTestDataList.Fields, pFields)
    lTestDataCount = lTestDataList.Count
    lTestFieldCount = lTestFieldList.Count
    ReDim res(1 To lTestDataCount + 1, 1 To lTestFieldCount + IIf(pAttachement, 1, 0)) As Variant
    ReDim lRunFactory(1 To lTestDataCount)
    
    For col = 1 To lTestFieldCount
        res(1, col) = Get_Field_Name(pLabelType, lTestFieldList(col))
    Next col
    If pAttachement Then res(1, col) = "ATTACHEMENTS"
    For row = 1 To lTestDataCount
        Set lRunFactory(row) = lTestDataList(row).TSTestFactory.NewList(Empty)
        For col = 1 To lTestFieldCount
            res(row + 1, col) = Get_Field_Data(lTestFieldList(col), lTestDataList(row))
        Next col
        If pAttachement Then
            If lTestDataList(row).HasAttachment Then
                res(row + 1, col) = Conv_Objects_Members_To_String(lTestDataList(row).Attachments)
            End If
        End If
        totalRuns = totalRuns + lRunFactory(row).Count
        Update_ProgressBar 0.8 * (row / lTestDataCount)
    Next row
        
    Set lRunFieldList = Get_Active_Fields_Collection(lRunFactory(1).Fields, pFields)
    lRunFieldCount = lRunFieldList.Count
    If pAttachement Then lTestFieldCount = lTestFieldCount + 1
    
    ReDim res2(1 To totalRuns + 1, 1 To lTestFieldCount + lRunFieldCount + IIf(pAttachement, 1, 0)) As Variant
    For col = 1 To lTestFieldCount
        res2(1, col) = res(1, col)
    Next col
    For col = 1 To lRunFieldCount
        res2(1, lTestFieldCount + col) = Get_Field_Name(pLabelType, lRunFieldList(col))
    Next col
    If pAttachement Then res2(1, lTestFieldCount + col) = "ATTACHEMENTS"

    rowpos = 1
    For row = 1 To lTestDataCount
        Set lRunDataList = lRunFactory(row)
        For row2 = 1 To lRunDataList.Count
            rowpos = rowpos + 1
            For col = 1 To lTestFieldCount
                res2(rowpos, col) = res(row + 1, col)
            Next col
            For col = 1 To lRunFieldCount
                If lRunFieldList(col).Name = "TS_PATH" Then
                    res2(rowpos, lTestFieldCount + col) = lRunDataList(row2).Field("TS_SUBJECT").Path
                Else
                    res2(rowpos, lTestFieldCount + col) = Get_Field_Data(lRunFieldList(col), lRunDataList(row2))
                End If
            Next col
            If pAttachement Then
                If lRunDataList(row2).HasAttachment Then
                    res2(rowpos, lTestFieldCount + col) = Conv_Objects_Members_To_String(lRunDataList(row2).Attachments)
                End If
            End If
        Next row2
        Update_ProgressBar 0.8 + (0.2 * (row / lTestDataCount))
    Next row
    
    Get_Full_Factory_TestSet_With_Runs = res2
End Function


Public Function Get_Full_Factory_Tests_With_Steps(pLabelType As Label_T, pFields As Variant, Optional pDataFilter As String, Optional pAttachement As Boolean) As Variant
    Dim lTestFieldList As Collection, lTestFieldCount As Integer, lTestDataCount As Integer, lTestDataList As Object ' TDAPIOLELib.List
    Dim lStepFieldList As Collection, lStepFieldCount As Integer, lStepFactory() As Object, lStepDataList As Object  'TDAPIOLELib.List TDAPIOLELib.DesignStepFactory
    Dim row As Long, row2 As Long, col As Integer, totalSteps As Long, rowpos As Long

    Set lTestDataList = G_QCConnection.testFactory.NewList(pDataFilter)
    Set lTestFieldList = Get_Active_Fields_Collection(lTestDataList.Fields, pFields)
    lTestDataCount = lTestDataList.Count
    lTestFieldCount = lTestFieldList.Count
    ReDim res(1 To lTestDataCount + 1, 1 To lTestFieldCount + IIf(pAttachement, 1, 0)) As Variant
    ReDim lStepFactory(1 To lTestDataCount)
    
    For col = 1 To lTestFieldCount
        res(1, col) = Get_Field_Name(pLabelType, lTestFieldList(col))
    Next col
    If pAttachement Then res(1, col) = "ATTACHEMENTS"
    For row = 1 To lTestDataCount
        Set lStepFactory(row) = lTestDataList(row).DesignStepFactory.NewList(Empty)
        For col = 1 To lTestFieldCount
            If lTestFieldList(col).Name = "TS_PATH" Then
                res(row + 1, col) = lTestDataList(row).Field("TS_SUBJECT").Path
            Else
                res(row + 1, col) = Get_Field_Data(lTestFieldList(col), lTestDataList(row))
            End If
        Next col
        If pAttachement Then
            If lTestDataList(row).HasAttachment Then
                res(row + 1, col) = Conv_Objects_Members_To_String(lTestDataList(row).Attachments)
            End If
        End If
        totalSteps = totalSteps + lStepFactory(row).Count
        Update_ProgressBar 0.8 * (row / lTestDataCount)
    Next row
        
    Set lStepFieldList = Get_Active_Fields_Collection(lStepFactory(1).Fields, pFields)
    lStepFieldCount = lStepFieldList.Count
    If pAttachement Then lTestFieldCount = lTestFieldCount + 1
    
    ReDim res2(1 To totalSteps + 1, 1 To lTestFieldCount + lStepFieldCount + IIf(pAttachement, 1, 0)) As Variant
    For col = 1 To lTestFieldCount
        res2(1, col) = res(1, col)
    Next col
    For col = 1 To lStepFieldCount
        res2(1, lTestFieldCount + col) = Get_Field_Name(pLabelType, lStepFieldList(col))
    Next col
    If pAttachement Then res2(1, lTestFieldCount + col) = "ATTACHEMENTS"

    rowpos = 1
    For row = 1 To lTestDataCount
        Set lStepDataList = lStepFactory(row) '.NewList(Empty)
        For row2 = 1 To lStepDataList.Count
            rowpos = rowpos + 1
            For col = 1 To lTestFieldCount
                res2(rowpos, col) = res(row + 1, col)
            Next col
            For col = 1 To lStepFieldCount
                res2(rowpos, lTestFieldCount + col) = Get_Field_Data(lStepFieldList(col), lStepDataList(row2))
            Next col
            If pAttachement Then
                If lStepDataList(row2).HasAttachment Then
                    res2(rowpos, lTestFieldCount + col) = Conv_Objects_Members_To_String(lStepDataList(row2).Attachments)
                End If
            End If
        Next row2
        Update_ProgressBar 0.8 + (0.2 * (row / lTestDataCount))
    Next row
    
    Get_Full_Factory_Tests_With_Steps = res2
End Function

Private Function Get_Factory_Data(pFactory As Factory_T, pLabelType As Label_T, ByRef pDataList As Object, ByRef pFieldsList As Collection, ByVal pAttachement As Boolean) As Variant
    Dim row As Long, col As Integer, lFieldCount As Integer, lDataCount As Long, lOptAttachement As Boolean
    lFieldCount = pFieldsList.Count
    lDataCount = pDataList.Count
    ReDim res(1 To lDataCount + 1, 1 To lFieldCount + IIf(pAttachement, 1, 0)) As Variant
    For col = 1 To lFieldCount
        res(1, col) = Get_Field_Name(pLabelType, pFieldsList(col))
    Next col
    If pAttachement Then res(1, col) = "ATTACHEMENTS"
    For row = 1 To lDataCount
        For col = 1 To lFieldCount
            If pFactory = Tests And pFieldsList(col).Name = "TS_PATH" Then
                res(row + 1, col) = pDataList(row).Field("TS_SUBJECT").Path
            Else
                res(row + 1, col) = Get_Field_Data(pFieldsList(col), pDataList(row))
            End If
        Next col
        If pAttachement Then
            If pDataList(row).HasAttachment Then
                res(row + 1, col) = Conv_Objects_Members_To_String(pDataList(row).Attachments)
            End If
        End If
        Update_ProgressBar (row / lDataCount)
    Next row
    Get_Factory_Data = res
End Function

Private Function Update_ProgressBar(pValue)
    If Not G_AttachedProgressBar Is Nothing Then G_AttachedProgressBar.SetProgress (pValue)
    DoEvents
End Function

Private Function Get_Field_Name(ByRef pLabelType As Label_T, ByRef pField As Object) As String
    Select Case pLabelType
        Case Label_T.SystemLabel
            Get_Field_Name = pField.Name
        Case Label_T.SystemLabel
            Get_Field_Name = pField.Property.UserLabel
        Case Label_T.SystemAndUserLabels
            Get_Field_Name = pField.Name & " " & pField.Property.UserLabel
    End Select
End Function

Private Function Get_Field_Data(ByRef pField As Object, ByRef pData As Object) As String
    If pField.Type = 4 Then
        Get_Field_Data = Conv_HTML(pData.Field(pField.Name))
    Else
        Get_Field_Data = pData.Field(pField.Name)
    End If
End Function

Private Function Get_Active_Fields_Collection(pFields As Object, ByRef pRequestedFields) As Collection
    Dim i As Integer, j As Integer, filter As Boolean
    Set Get_Active_Fields_Collection = New Collection
    If IsArray(pRequestedFields) Then filter = True
    For i = 1 To pFields.Count
        If pFields(i).Property.IsActive And pFields(i).Property.IsVisible Then
            If filter Then
                For j = 1 To UBound(pRequestedFields)
                    If pFields(i).Name = pRequestedFields(j) Or pFields(i).Property.UserLabel = pRequestedFields(j) Then
                        Get_Active_Fields_Collection.Add pFields(i)
                        Exit For
                    End If
                Next j
            Else
                Get_Active_Fields_Collection.Add pFields(i)
            End If
        End If
    Next i
End Function

Private Function Conv_Objects_Members_To_String(ByRef pObject As Object) As String
    Dim lObjList As Object 'TDAPIOLELib.List
    Dim obj As Object
    Dim ret As String
    Set lObjList = pObject.NewList("")
    For Each obj In lObjList
        If ret <> Empty Then ret = ret & ","
        ret = ret & obj.Name
    Next
    Conv_Objects_Members_To_String = ret
End Function

Public Function get_TestCase_Subjects() As Variant
    Dim lTestFactory As Object 'TDAPIOLELib.testFactory
    Dim lList As Object 'TDAPIOLELib.List
    Dim i As Integer, ex As Integer, j As Integer
    Set lTestFactory = G_QCConnection.testFactory
    
    Dim lTreeManager As Object 'TDAPIOLELib.TreeManager
    Dim lSubjectNode, lRoot As Object 'TDAPIOLELib.SubjectNode
    Set lTreeManager = G_QCConnection.TreeManager
    Set lRoot = lTreeManager.TreeRoot("Subject")
    
    Dim nodes As New Collection
    Dim nbchild As Integer
    
    get_TestCase_Subjects_Recursive lRoot, nodes
            
End Function

Private Sub get_TestCase_Subjects_Recursive(ByRef pNode As Object, ByRef pNodes As Collection)
    Dim i As Integer
    pNodes.Add pNode, CStr(pNode.NodeID)
    For i = 1 To pNode.Count
        get_TestCase_Subjects_Recursive pNode.Child(i), pNodes
    Next i
End Sub

Private Function Conv_HTML(ByVal pString) As String
    Dim i, istag As Boolean, char As String * 1, res As String
    If Len(pString) > 910 Then pString = Left(pString, 907) & "..."
    pString = Replace(pString, "<p>", Chr(10))
    pString = Replace(pString, "<br>", Chr(10))
    For i = 1 To Len(pString)
        char = Mid(pString, i, 1)
        If char = "<" Or istag Then
            If char = "<" Then
                istag = True
            Else
               If char = ">" Then istag = False
            End If
        Else
            Conv_HTML = Conv_HTML & char
        End If
    Next
    Conv_HTML = Replace(Conv_HTML, "&quot;", Chr(34))
    Conv_HTML = Replace(Conv_HTML, "&lt;", "<")
    Conv_HTML = Replace(Conv_HTML, "&gt;", ">")
End Function

Private Function TrimNull(ByVal pValue As Variant) As String
    If InStr(pValue, vbNullChar) <> 0 Then
        TrimNull = Left(pValue, InStr(pValue, vbNullChar) - 1)
    Else
        TrimNull = pValue
    End If
    If Len(TrimNull) > 910 Then
        TrimNull = Mid$(TrimNull, 1, 910)
    End If
End Function

Private Function GetParam(p_param As String) As String
    GetParam = TrimNull(GetSetting(Setting_AppName, Setting_Section, p_param))
End Function

Private Function SetParam(p_param As String, p_value As String) As String
    SaveSetting Setting_AppName, Setting_Section, p_param, TrimNull(p_value)
End Function

Private Function Convert_StringCollection_ToArray(ByRef pCollectionString As Object) As Variant
    Dim lList() As String, lCount As Integer, i As Integer
    lCount = pCollectionString.Count
    If lCount > 0 Then
        ReDim lList(1 To lCount)
        For i = 1 To lCount
            lList(i) = pCollectionString(i)
        Next i
        Convert_StringCollection_ToArray = lList
    Else
        Convert_StringCollection_ToArray = Array()
    End If
End Function

Private Function Encode(pString As String, pKey As String) As String
    Dim i As Integer, keylen As Integer, keypos As Integer, strcar As Integer
    keylen = Len(pKey)
    For i = 1 To Len(pString)
        strcar = AscW(Mid(pString, i, 1))
        If strcar = 0 Then Exit For
        If keypos = keylen Then
            keypos = 1
        Else
            keypos = keypos + 1
        End If
        Encode = Encode & Right("0" & Hex(strcar Xor Asc(Mid(pKey, keypos, 1))), 2)
    Next i
End Function

Private Function Decode(pString As String, pKey As String) As String
    Dim i As Integer, keylen As Integer, keypos As Integer, strcar As Integer
    keylen = Len(pKey)
    For i = 1 To Len(pString) Step 2
        If Mid(pString, i, 1) = vbNullChar Then Exit For
        strcar = Val("&H" & Mid(pString, i, 2))
        If keypos = keylen Then
            keypos = 1
        Else
            keypos = keypos + 1
        End If
        Decode = Decode & (ChrW(strcar Xor Asc(Mid(pKey, keypos, 1))))
    Next i
End Function



